(in-package :iorek)

(defstruct symbol-table
  (map (fset:map)) (search-namespaces (seq)) (exported-symbols (seq)))

(defstruct symbol name namespace (table (make-symbol-table)) (properties (fset:map)))

(defvar *root-symbol* (make-symbol :name ""))

(defvar *namespace*)

(defun ensure-namespace (ns)
  (cond
   ((symbol-p ns) ns)
   (t (error "Not a namespace designator: ~A" ns))))

(defun export (symbol &optional (namespace *namespace*))
  ;;TODO error check (find-symbol)
  (setf
   (symbol-table-exported-symbols (symbol-table namespace))
   (with-first (symbol-table-exported-symbols (symbol-table namespace)) symbol))
  symbol)

(defun alias (symbol alternative-name &optional (namespace *namespace*))
  (multiple-value-bind (_ found?)
      (@ (symbol-table-map (symbol-table namespace)) alternative-name)
    (declare (ignore _))
    (if found?
        (error "A symbol named ~S already exists in namespace ~A. Please unintern it first." alternative-name namespace)
        (setf (@ (symbol-table-map (symbol-table namespace)) alternative-name)
              symbol))))

(defun intern (symbol-name &optional (namespace *namespace*))
  (let ((namespace (ensure-namespace namespace)))
    (multiple-value-bind (symbol found?) (find-symbol symbol-name namespace nil)
      (if found?
          symbol
          (intern-symbol (make-symbol :name symbol-name :namespace namespace)
                         (symbol-table namespace))))))

(defgeneric intern-symbol (symbol symbol-table))

(defmethod intern-symbol (symbol (symbol-table symbol-table))
  (setf (@ (symbol-table-map symbol-table) (symbol-name symbol)) symbol))

(defun find-symbol (symbol-name &optional (namespace *namespace*) (exported-only t))
  (let ((namespace (ensure-namespace namespace)))
    (multiple-value-bind (symbol found?)
        (@ (symbol-table-map (symbol-table namespace)) symbol-name)
      (if (and found? (or (not exported-only)
                          (find symbol (symbol-table-exported-symbols (symbol-table namespace)))))
          (values symbol t)
          (progn
            (do-seq (ns (symbol-table-search-namespaces (symbol-table namespace)))
              (multiple-value-bind (symbol found?)
                  (find-symbol symbol-name ns t)
                (when found? (return-from find-symbol (values symbol t)))))
            (if (symbol-namespace namespace)
                (find-symbol symbol-name (symbol-namespace namespace) t)
                (values nil nil)))))))

(defmethod compare ((s1 symbol) (s2 symbol))
  (let ((cmp (compare (symbol-name s1) (symbol-name s2))))
    (if (eq cmp :equal)
        (compare (symbol-namespace s1) (symbol-namespace s2))
      cmp)))

(defmethod make-load-form ((object symbol) &optional environment)
  (declare (ignore environment))
  (if (eq object *root-symbol*)
      '*root-symbol*
      `(print (intern ,(symbol-name object) ,(symbol-namespace object)))))

;;Default symbols
(defvar *symbol-lang* (intern "lang" *root-symbol*))
;;Binding
(defvar *symbol-lang-function* (intern "function" *symbol-lang*))
(defvar *symbol-lang-let* (intern "let" *symbol-lang*))
;;Conditionals
(defvar *symbol-lang-true* (intern "true" *symbol-lang*))
(defvar *symbol-lang-false* (intern "false" *symbol-lang*))
(defvar *symbol-lang-if* (intern "if" *symbol-lang*))
;;Quote
(defvar *symbol-lang-quote* (intern "quote" *symbol-lang*))
;;Template
(defvar *symbol-lang-template* (intern "template" *symbol-lang*))
(defvar *symbol-lang-insert* (intern "insert" *symbol-lang*))
(defvar *symbol-lang-insert-many* (intern "insert-many" *symbol-lang*))
;;Variables
(defvar *symbol-lang-defvar* (intern "defvar" *symbol-lang*))
(defvar *symbol-lang-!* (intern "!" *symbol-lang*))
;;Functions
(defvar *symbol-lang-defun* (intern "defun" *symbol-lang*))
(defvar *symbol-lang-lambda* (intern "lambda" *symbol-lang*))
(defvar *symbol-lang-λ* (alias *symbol-lang-lambda* "λ" *symbol-lang*))
(defvar *symbol-lang-apply* (intern "apply" *symbol-lang*))
(defvar *symbol-lang-compose* (intern "compose" *symbol-lang*))
(defvar *symbol-lang-map* (intern "map" *symbol-lang*))
(defvar *symbol-lang-\|* (intern "|" *symbol-lang*))
(defvar *symbol-lang-\|\|* (intern "||" *symbol-lang*))
(defvar *symbol-lang-\|\|\|* (intern "|||" *symbol-lang*))
(defvar *symbol-lang-\|\|\|\|* (intern "||||" *symbol-lang*))
;;Macros
(defvar *symbol-lang-defmacro* (intern "defmacro" *symbol-lang*))
;;Misc
(defvar *symbol-lang-do* (intern "do" *symbol-lang*))
(defvar *symbol-lang-exit* (intern "exit" *symbol-lang*))
(defvar *symbol-lang-values* (intern "values" *symbol-lang*))
;;Symbols
(defvar *symbol-lang-alias* (intern "alias" *symbol-lang*))
(defvar *symbol-lang-export* (intern "export" *symbol-lang*))
(defvar *symbol-lang-find-symbol* (intern "find-symbol" *symbol-lang*))
(defvar *symbol-lang-intern* (intern "intern" *symbol-lang*))
(defvar *symbol-lang-namespace* (intern "namespace" *symbol-lang*))
(defvar *symbol-lang-*namespace** (intern "*namespace*" *symbol-lang*))
(defvar *symbol-lang-operator?* (intern "operator?" *symbol-lang*))
(defvar *symbol-lang-operator-precedence* (intern "operator-precedence" *symbol-lang*))
;;Environment
(defvar *symbol-lang-symbol-value* (intern "symbol-value" *symbol-lang*))
(defvar *symbol-lang-symbol-function* (intern "symbol-function" *symbol-lang*))
;;Math
(defvar *symbol-lang-+* (intern "+" *symbol-lang*))
(defvar *symbol-lang--* (intern "-" *symbol-lang*))
(defvar *symbol-lang-** (intern "*" *symbol-lang*))
(defvar *symbol-lang-/* (intern "/" *symbol-lang*))
(defvar *symbol-lang->* (intern ">" *symbol-lang*))
(defvar *symbol-lang-<* (intern "<" *symbol-lang*))
(defvar *symbol-lang->=* (intern ">=" *symbol-lang*))
(defvar *symbol-lang-<=* (intern "<=" *symbol-lang*))
(defvar *symbol-lang-=* (intern "=" *symbol-lang*))
;;Equality relations
(defvar *symbol-lang-eq?* (intern "eq?" *symbol-lang*))
(defvar *symbol-lang-eql?* (intern "eql?" *symbol-lang*))
;;Data structures
(defvar *symbol-lang-adjoin* (intern "adjoin" *symbol-lang*))
(defvar *symbol-lang-append* (intern "append" *symbol-lang*))
(defvar *symbol-lang-list* (intern "list" *symbol-lang*))
(defvar *symbol-lang-list?* (intern "list?" *symbol-lang*))
(defvar *symbol-lang-lookup* (intern "lookup" *symbol-lang*))
(defvar *symbol-lang-@* (alias *symbol-lang-lookup* "@" *symbol-lang*))
(defvar *symbol-lang-subseq* (intern "subseq" *symbol-lang*))
;;Reading
(defvar *symbol-lang-read-object* (intern "read-object" *symbol-lang*))
(defvar *symbol-lang-read-expression* (intern "read-expression" *symbol-lang*))
;;Printing
(defvar *symbol-lang-print* (intern "print" *symbol-lang*))
;;Templating
(defvar *symbol-lang-template* (intern "template" *symbol-lang*))
(defvar *symbol-lang-insert* (intern "insert" *symbol-lang*))
(defvar *symbol-lang-insert-many* (intern "insert-many" *symbol-lang*))

(export *symbol-lang* *root-symbol*)
(do-map (k v (symbol-table-map (symbol-table *symbol-lang*)))
  (declare (ignore k))
  (export v *symbol-lang*))

(defvar *symbol-iorek* (intern "iorek" *root-symbol*))
(setf (symbol-table-search-namespaces (symbol-table *symbol-iorek*))
      (seq *symbol-lang*))

(setf *namespace* *symbol-iorek*)

(defun symbol? (object)
  (if (symbol-p object) *symbol-lang-true* *symbol-lang-false*))